Illusion Game Reliability

Preprocessing

Preprocessing

library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)

illusion1 <- read.csv("../data/raw_illusion1.csv") |>
  mutate(
    Illusion_Effect = fct_relevel(as.factor(Illusion_Effect), "Incongruent", "Congruent"),
    Block = as.factor(Block)
  )

illusion2 <- read.csv("../data/raw_illusion2.csv") |>
  mutate(
    Illusion_Effect = fct_relevel(as.factor(Illusion_Effect), "Incongruent", "Congruent"),
    Block = as.factor(Block)
  )

perceptual <- read.csv("../data/raw_perceptual.csv") |>
  mutate(
    Block = as.factor(Block)
  )

sub <- read.csv("../data/raw_questionnaires.csv") |> 
  mutate(
    Education = fct_relevel(Education, 
                            # "Prefer not to Say", 
                            "High school", "Bachelor", "Master", "Doctorate", "Other")
  )

# For prolific:
# bayestestR::point_estimate(sub$Duration_Session1)
# plot(bayestestR::estimate_density(sub$Duration_Session1))

Outlier Detection (Tasks)

# Dear participant, thank you for participating in our study. Unfortunately, our system detected multiple issues in your data (such as implausibly short responses - in particular in the 2nd part of the study, random-like pattern of answers, or the same response to different scales - as some were designed to trigger various answers), which makes it unusable. We understand that you might have been in a hurry or had some other issues, and so we kindly ask you to return your participation; we hope to open-up more slots in the future would you be interested to participate again. 

# Dear participant, thank you for participating in our study. Unfortunately, our system detected multiple issues in your data (such as implausibly short responses - in particular in the 2nd part of the study, random-like pattern of answers, or the same response to different scales - as some were designed to trigger various answers), which makes it unusable for us. We understand that you might have been in a hurry or had some other issues; we hope to open-up more slots in the future would you be interested to participate again. 

outliers_perceptual <- c(
  "S003",
  "S008"
)
outliers_illusion1 <- c(
  "S008"
  )
outliers_illusion2 <- c(
  "S003"
)

We removed 1, 2, and 1 participants for the illusion task - session 1, perceptual task, and illusion task - session 2 respectively, upon inspection of the average error rage (when close to 50%, suggesting random answers) and/or when the reaction time distribution was implausibly fast.

Descriptive Table

data <- rbind(illusion1, illusion2, perceptual) |>
  filter(RT < 10) |>
  mutate(
    Participant = fct_rev(Participant),
    Task = fct_relevel(Task, "Illusion_Session1", "Perceptual", "Illusion_Session2")
  )

table <- data |>
  group_by(Participant, Task) |>
  summarize(
    Error = sum(Error) / n(),
    RT = mean(RT)
  ) |>
  ungroup() |>
  arrange(desc(Error)) |>
  tidyr::pivot_wider(names_from = "Task", values_from = c("Error", "RT"), names_vary = "slowest") |>
  datawizard::data_relocate(ends_with("Session2"), after = -1) |>
  arrange(desc(Error_Illusion_Session1))

data.frame(Participant = c("Average"), t(sapply(table[2:ncol(table)], mean, na.rm = TRUE))) |>
  rbind(table) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE, background = "grey", color = "white") |>
  kableExtra::row_spec(which(table$Participant %in% c(outliers_perceptual, outliers_illusion1, outliers_illusion2)) + 1, background = "#EF9A9A") |>
  # kableExtra::column_spec(2, color="white",
  #                         background = kableExtra::spec_color(c(NA, table$Error_Illusion_Session1))) |>
  kableExtra::kable_styling(full_width = TRUE) |>
  kableExtra::scroll_box(width = "100%", height = "500px")

Participant	Error_Perceptual	RT_Perceptual	Error_Illusion_Session1	RT_Illusion_Session1	RT_Illusion_Session2	Error_Illusion_Session2
Average	0.068	0.678	0.182	0.766	0.731	0.265
S008	0.500	0.347	0.417	0.610
S002	0.115	0.872	0.346	0.713	0.945	0.396
S023	0.125	0.619	0.346	0.631
S070	0.149	1.014	0.314	1.118
S080	0.120	0.532	0.286	0.477
S087	0.151	0.589	0.279	0.576
S021	0.250	0.703	0.263	0.544
S059	0.021	0.488	0.260	0.542
S073	0.104	0.596	0.258	0.665
S006	0.089	0.620	0.258	0.529	0.723	0.216
S094	0.089	0.514	0.250	0.602
S053	0.151	0.475	0.245	0.511
S048	0.052	0.502	0.242	0.502
S101	0.177	0.406	0.240	0.427
S025	0.073	0.598	0.237	0.713
S007	0.089	0.770	0.234	0.894
S036	0.068	0.749	0.232	0.845
S083	0.042	0.561	0.229	0.588
S063	0.042	0.797	0.228	0.885
S014	0.047	0.548	0.227	0.641
S097	0.068	0.528	0.224	0.791
S019	0.052	0.496	0.224	0.618
S046	0.073	0.553	0.221	0.620
S042	0.161	0.493	0.221	0.560
S092	0.036	0.810	0.217	1.202
S079	0.052	0.588	0.216	0.586
S003	0.214	0.441	0.211	0.853	0.331	0.371
S064	0.073	0.714	0.211	0.885
S093	0.057	0.512	0.208	0.516
S043	0.057	0.823	0.208	0.688
S086	0.099	0.717	0.206	0.726
S096	0.094	0.473	0.203	0.554
S100	0.083	0.730	0.201	0.740
S066	0.031	0.728	0.201	0.859
S001	0.323	0.946	0.199	0.986
S052	0.031	0.541	0.195	0.537
S085	0.177	0.637	0.193	0.824
S047	0.094	0.624	0.191	0.823
S072	0.057	0.960	0.190	0.925
S082	0.125	0.410	0.188	0.470
S067	0.099	0.550	0.188	0.560
S026	0.036	0.732	0.182	0.934
S017	0.068	0.534	0.180	0.606
S040	0.026	0.829	0.180	0.929
S089	0.031	0.603	0.178	0.888
S044	0.016	0.642	0.177	0.665
S035	0.099	0.497	0.177	0.523
S030	0.068	0.546	0.177	0.718
S013	0.062	0.563	0.177	0.706
S076	0.031	0.671	0.174	0.655
S034	0.099	0.645	0.174	0.792
S022	0.078	0.500	0.174	0.601
S065	0.021	0.605	0.172	0.811
S062	0.042	0.641	0.172	0.708
S038	0.115	0.618	0.167	0.691
S033	0.083	0.698	0.167	0.752
S024	0.042	0.756	0.167	0.735
S020	0.073	0.833	0.167	0.820
S050	0.016	0.714	0.164	1.025
S009	0.010	0.633	0.164	0.833
S054	0.057	0.535	0.161	0.576
S039	0.083	0.517	0.161	0.524
S004	0.010	0.800	0.161	1.051
S011	0.042	0.657	0.159	0.755	0.687	0.185
S071	0.016	0.836	0.159	0.748
S068	0.052	0.624	0.156	1.011
S032	0.031	0.585	0.154	0.550
S088	0.026	0.878	0.148	1.056
S077	0.057	1.019	0.148	0.884
S074	0.052	0.533	0.146	0.730
S058	0.036	0.596	0.146	0.609
S057	0.021	0.562	0.146	0.645
S084	0.000	0.966	0.143	0.932
S045	0.010	0.912	0.141	0.730
S015	0.047	0.643	0.135	0.580
S098	0.021	0.849	0.134	0.993
S095	0.021	0.931	0.133	1.531
S091	0.031	0.561	0.130	0.673
S081	0.021	0.718	0.130	0.733
S075	0.068	0.890	0.130	1.089
S060	0.042	0.695	0.130	0.947
S041	0.052	0.672	0.130	0.751
S051	0.016	0.569	0.128	0.753
S037	0.047	0.756	0.128	0.965
S018	0.052	0.682	0.128	0.816
S016	0.021	0.605	0.128	0.678
S061	0.021	0.593	0.126	1.281
S055	0.057	0.553	0.125	0.756
S031	0.016	0.669	0.125	0.780
S005	0.000	0.999	0.125	0.877
S010	0.068	1.439	0.122	1.152	0.968	0.159
S099	0.016	0.696	0.122	0.691
S027	0.010	0.706	0.122	0.730
S028	0.052	0.775	0.117	0.887
S056	0.052	0.568	0.115	0.664
S069	0.010	0.859	0.107	0.893
S078	0.000	1.016	0.104	1.021
S090	0.026	0.610	0.096	0.809
S049	0.042	0.990	0.096	0.968
S029	0.068	0.875	0.094	0.924
S012	0.016	0.699	0.094	0.928

Reaction Time Distribution

p <- data |>
  filter((as.numeric(gsub("\\D", "", Participant)) <= 11) | (as.numeric(gsub("\\D", "", Participant)) >= 61)) |>
  estimate_density(select = "RT", at = c("Participant", "Task", "Block")) |>
  group_by(Participant) |>
  normalize(select = "y") |>
  ungroup() |>
  mutate(
    # Participant = fct_relevel(Participant, as.character(table$Participant)),
    color = case_when(
      Participant %in% outliers_perceptual & Task == "Perceptual" ~ "red",
      Participant %in% outliers_illusion1 & Task == "Illusion_Session1" ~ "red",
      Participant %in% outliers_illusion2 & Task == "Illusion_Session2" ~ "red",
      TRUE ~ "blue"
    ),
    Task = fct_recode(Task,
      "Illusion task (session 1)" = "Illusion_Session1",
      "Illusion task (session 2)" = "Illusion_Session2",
      "Perceptual task" = "Perceptual"
    )
  ) |>
  ggplot(aes(x = x, y = y)) +
  geom_area(data = normalize(estimate_density(data, select = "RT"), select = "y"), alpha = 0.2) +
  geom_line(aes(color = color, group = interaction(Participant, Block), linetype = Block), size = 0.5) +
  geom_vline(xintercept = 0.125, linetype = "dashed", color = "red", size = 0.5) +
  scale_color_manual(values = c("red" = "#F44336", "orange" = "#FF9800", "blue" = "blue"), guide = "none") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0)) +
  coord_cartesian(xlim = c(0, 2)) +
  theme_modern() +
  theme(axis.text.y = element_blank()) +
  facet_grid(Participant ~ Task) +
  labs(y = "", x = "Reaction Time (s)")
# p
ggsave("figures/outliers_RT.png", p, width = 8, height = 24, dpi = 100)

knitr::include_graphics("figures/outliers_RT.png")

illusion1 <- filter(illusion1, !Participant %in% outliers_illusion1)
illusion2 <- filter(illusion2, !Participant %in% outliers_illusion2)
perceptual <- filter(perceptual, !Participant %in% outliers_perceptual)

Outliers Detection (Blocks)

For each block, we computed the error rate and, if more than 50%, we discarded the whole block (as it likely indicates that instructions got mixed up, for instance participants were selecting the smaller instead of the bigger circle).

data <- rbind(illusion1, illusion2, perceptual) |>
  group_by(Participant, Task, Illusion_Type, Block) |>
  summarize(ErrorRate_per_block = sum(Error) / n()) |>
  ungroup() |>
  arrange(desc(ErrorRate_per_block))


data |>
  estimate_density(at = c("Task", "Illusion_Type", "Block"), method = "KernSmooth") |>
  ggplot(aes(x = x, y = y)) +
  geom_line(aes(color = Illusion_Type, linetype = Block)) +
  geom_vline(xintercept = 0.5, linetype = "dashed") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0)) +
  scale_color_manual(values = c("Ebbinghaus" = "#2196F3", "MullerLyer" = "#4CAF50", "VerticalHorizontal" = "#FF5722")) +
  labs(y = "Distribution", x = "Error Rate") +
  theme_modern() +
  facet_wrap(~Task)

remove_badblocks <- function(df) {
  n <- nrow(df)
  df <- df |>
    group_by(Participant, Illusion_Type, Block) |>
    mutate(ErrorRate_per_block = sum(Error) / n()) |>
    ungroup() |>
    filter(ErrorRate_per_block < 0.5) |>
    select(-ErrorRate_per_block)
  text <- paste0(
    "We removed ",
    n - nrow(df),
    " (",
    insight::format_value((n - nrow(df)) / n, as_percent = TRUE),
    ") trials belonging to bad blocks."
  )
  list(data = df, text = text)
}

out <- remove_badblocks(illusion1)
print(paste("Illusion (session 1):", out$text))

[1] “Illusion (session 1): We removed 128 (0.33%) trials belonging to bad blocks.”

illusion1 <- out$data

out <- remove_badblocks(illusion2)
print(paste("Illusion (session 2):", out$text))

[1] “Illusion (session 2): We removed 64 (4.17%) trials belonging to bad blocks.”

illusion2 <- out$data

out <- remove_badblocks(perceptual)
print(paste("Perceptual task:", out$text))

[1] “Perceptual task: We removed 96 (0.51%) trials belonging to bad blocks.”

perceptual <- out$data

Outliers Detection (Trials)

Reaction Time per Trial

check_trials <- function(df) {
  data <- df |>
    mutate(Outlier = ifelse(RT >= 10, TRUE, FALSE)) |>
    group_by(Participant) |>
    mutate(Outlier = ifelse(RT < 0.125 | standardize(RT, robust = TRUE) > 4, TRUE, Outlier)) |>
    ungroup()

  p1 <- data |>
    filter(RT < 10) |>
    estimate_density(select = "RT", at = "Participant") |>
    group_by(Participant) |>
    normalize(select = "y") |>
    ungroup() |>
    merge(data |>
      group_by(Participant) |>
      mutate(Threshold = median(RT) + 4 * mad(RT)) |>
      filter(Error == 0) |>
      summarize(Threshold = mean(Threshold))) |>
    mutate(Outlier = ifelse(x >= Threshold, TRUE, FALSE)) |>
    ggplot(aes(x = x, y = y)) +
    geom_area(data = normalize(estimate_density(filter(data, RT < 10), select = "RT"), select = "y"), alpha = 0.2) +
    geom_line(aes(color = Participant, linetype = Outlier), alpha = 0.2) +
    geom_vline(xintercept = c(125), linetype = "dashed", color = "red") +
    scale_color_material_d("rainbow", guide = "none") +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) +
    guides(linetype = "none") +
    coord_cartesian(xlim = c(0, 5)) +
    theme_modern() +
    theme(axis.text.y = element_blank()) +
    labs(y = "", x = "Reaction Time (s)")


  p2 <- data |>
    group_by(Participant) |>
    summarize(Outlier = sum(Outlier) / nrow(illusion1)) |>
    mutate(Participant = fct_reorder(Participant, Outlier)) |>
    ggplot(aes(x = Participant, y = Outlier)) +
    geom_bar(stat = "identity", aes(fill = Participant)) +
    scale_fill_material_d("rainbow", guide = "none") +
    scale_x_discrete(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
    see::theme_modern() +
    theme(axis.text.x = element_blank()) +
    labs(y = "Percentage of outlier trials")

  text <- paste0(
    "We removed ",
    sum(data$Outlier),
    " (",
    insight::format_value(sum(data$Outlier) / nrow(data), as_percent = TRUE),
    ") outlier trials (125 ms < RT < 4 MAD above median)."
  )

  data <- filter(data, Outlier == FALSE)
  data$Outlier <- NULL

  list(p = p1 / p2, data = data, text = text)
}

Illusion Task (Session 1)

out <- check_trials(illusion1)
print(paste("Illusion (session 1):", out$text))

[1] “Illusion (session 1): We removed 1335 (3.49%) outlier trials (125 ms < RT < 4 MAD above median).”

out$p

illusion1 <- out$data

Illusion Task (Session 2)

out <- check_trials(illusion2)
print(paste("Illusion (session 2):", out$text))

[1] “Illusion (session 2): We removed 49 (3.33%) outlier trials (125 ms < RT < 4 MAD above median).”

out$p

illusion2 <- out$data

Perceptual Task

out <- check_trials(perceptual)
print(paste("Perceptual task:", out$text))

[1] “Perceptual task: We removed 853 (4.51%) outlier trials (125 ms < RT < 4 MAD above median).”

out$p

perceptual <- out$data

Outlier Detection (Questionnaires)

Multivariate Detection

We compute a multivariate outlier score.

outliers <- sub |> 
  select(AttentionCheck_Session1, 
         IPIP6_RT, PID5_RT, GCBS_RT, ASQ_RT, LIE_RT, SPQ_RT, 
         IPIP6_SD, PID5_SD, PHQ4_SD) |> 
  standardize() |> 
  performance::check_outliers(method = c("mahalanobis", "mahalanobis_robust", "mcd", "ics"))

sub$Potential_Outliers <- as.data.frame(outliers)$Outlier
outliers
## 9 outliers detected: cases 7, 42, 45, 49, 51, 78, 85, 91, 95.
## - Based on the following methods and thresholds: mahalanobis (29.59),
##   mahalanobis_robust (29.59), mcd (29.59), ics (0).
## - For variables: AttentionCheck_Session1, IPIP6_RT, PID5_RT, GCBS_RT,
##   ASQ_RT, LIE_RT, SPQ_RT, IPIP6_SD, PID5_SD, PHQ4_SD.
## 
## Note: Outliers were classified as such by at least half of the selected methods. 
## 
## -----------------------------------------------------------------------------
## The following observations were considered outliers for two or more variables 
## by at least one of the selected methods: 
## 
##    Row  n_Mahalanobis n_Mahalanobis_robust          n_MCD          n_ICS
## 1    7 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 2   42 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 3   49 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 4   51 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 5   78 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 6   85 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 7   91 (Multivariate)       (Multivariate) (Multivariate) (Multivariate)
## 8   95 (Multivariate)       (Multivariate) (Multivariate)              0
## 9   11              0       (Multivariate) (Multivariate)              0
## 10  15              0       (Multivariate)              0              0
## 11  23              0       (Multivariate)              0              0
## 12  28              0       (Multivariate) (Multivariate)              0
## 13  29              0       (Multivariate) (Multivariate)              0
## 14  30              0       (Multivariate) (Multivariate)              0
## 15  32              0       (Multivariate) (Multivariate)              0
## 16  45              0       (Multivariate) (Multivariate) (Multivariate)
## 17  52              0       (Multivariate) (Multivariate)              0
## 18  57              0       (Multivariate) (Multivariate)              0
## 19  58              0       (Multivariate)              0              0
## 20  59              0       (Multivariate) (Multivariate)              0
## 21  60              0       (Multivariate)              0              0
## 22  68              0       (Multivariate) (Multivariate)              0
## 23  69              0       (Multivariate) (Multivariate)              0
## 24  80              0       (Multivariate) (Multivariate)              0
## 25  83              0       (Multivariate) (Multivariate)              0
## 26  88              0       (Multivariate) (Multivariate)              0
## 27  89              0       (Multivariate) (Multivariate)              0
## 28  92              0       (Multivariate) (Multivariate)              0
## 29  93              0       (Multivariate) (Multivariate)              0

Manual Check

outliers_questionnaires <- c(
  "S003", "S008", "S068"
)

We removed the questionnaire data from 3 participants upon inspection of attention checks and time taken to complete each questionnaires.

table <- sub |>
  mutate(
    Outlier_Task1 = Participant %in% outliers_illusion1,
    Outlier_Task2 = Participant %in% outliers_illusion2,
    Outlier_Task3 = Participant %in% outliers_perceptual,
    Outlier_Tasks = Outlier_Task1 + Outlier_Task2 + Outlier_Task3
  ) |>
  select(
    Participant,
    Outlier_Tasks,
    Potential_Outliers,
    AttentionCheck_Session1,
    IPIP6_RT, PID5_RT, ASQ_RT, SPQ_RT,
    IPIP6_SD, PID5_SD, PHQ4_SD,
    AttentionCheck_Session2,
    BPD_RT, MAIA_RT, PI_RT,
    BPD_SD, MAIA_SD, PI_SD
  ) |> 
  # mutate(across(ends_with("IPIP6_RT") | ends_with("IPIP6_SD"), standardize)) |> 
  # arrange(desc(Outlier_Tasks), AttentionCheck_Session1) 
  arrange(desc(Participant))

t <- data.frame(Participant = c("Average"), t(sapply(table[2:ncol(table)], mean, na.rm = TRUE))) |>
  rbind(table) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE) |>
  kableExtra::row_spec(which(table$Participant %in% outliers_questionnaires) + 1, background = "#EF9A9A")

for (i in 2:ncol(table)) {
  t <- kableExtra::column_spec(
    t, i,
    color = "white",
    background = kableExtra::spec_color(
      c(NA, table[[i]]),
      option = "D",
      alpha = 1,
      # direction = ifelse(str_detect(names(table)[i], "_SD|Outlier"), 1, -1),
      na_color = "white",
    )
  )
}


t  |>
  kableExtra::row_spec(1, background = "grey") |> 
  kableExtra::kable_styling(full_width = TRUE, font_size = 9) |>
  kableExtra::scroll_box(width = "100%", height = "500px")

Participant	Outlier_Tasks	Potential_Outliers	AttentionCheck_Session1	IPIP6_RT	PID5_RT	ASQ_RT	SPQ_RT	IPIP6_SD	PID5_SD	PHQ4_SD	AttentionCheck_Session2	BPD_RT	MAIA_RT	PI_RT	BPD_SD	MAIA_SD	PI_SD
Average	0.04	0.173	0.959	1.889	2.591	2.503	3.22	0.200	0.670	0.406	0.656	1.052	2.99	3.55	0.241	0.129	0.701
S101	0.00	0.000	1.000	1.567	1.772	2.167	2.59	0.189	0.309	0.354
S100	0.00	0.000	1.000	1.696	2.091	1.793	2.91	0.141	0.577	0.000
S099	0.00	1.000	0.886	2.410	2.758	2.462	5.87	0.391	0.724	0.000
S098	0.00	0.000	1.000	1.644	1.681	1.968	3.40	0.207	0.957	0.707
S097	0.00	0.000	1.000	1.009	1.301	1.626	1.79	0.118	0.410	0.354
S096	0.00	0.250	1.000	1.673	1.483	1.753	2.44	0.350	0.924	1.414
S095	0.00	0.000	1.000	1.345	1.592	1.836	1.82	0.150	0.774	0.707
S094	0.00	0.000	0.964	1.700	2.307	2.572	4.05	0.185	0.855	0.000
S093	0.00	0.000	1.000	1.897	2.166	2.882	3.54	0.135	0.724	0.000
S092	0.00	0.000	1.000	1.178	2.504	2.125	2.87	0.200	0.814	0.354
S091	0.00	0.000	0.893	0.852	1.412	1.357	2.73	0.090	0.707	0.707
S090	0.00	0.000	1.000	1.984	2.113	2.294	3.32	0.246	0.618	0.354
S089	0.00	1.000	0.891	6.854	2.193	2.354	2.85	0.201	0.545	0.354
S088	0.00	0.000	1.000	2.068	2.503	3.000	4.07	0.237	0.410	0.000
S087	0.00	0.000	1.000	1.566	4.313	2.873	2.85	0.196	0.652	0.707
S086	0.00	0.000	0.924	2.013	2.597	2.479	3.68	0.292	0.834	0.000
S085	0.00	0.000	0.880	1.307	3.385	2.514	2.84	0.164	0.756	0.354
S084	0.00	0.000	1.000	1.795	1.887	2.720	3.04	0.206	0.797	0.354
S083	0.00	0.500	1.000	2.247	4.753	4.815	5.16	0.214	0.110	0.354
S082	0.00	0.000	0.999	0.789	1.058	1.190	1.35	0.291	1.384	0.354
S081	0.00	0.000	0.964	1.177	2.558	2.437	2.48	0.166	0.825	0.707
S080	0.00	0.500	1.000	1.130	3.723	2.102	3.19	0.426	0.817	1.061
S079	0.00	0.500	1.000	1.320	2.051	2.116	4.95	0.253	0.836	0.000
S078	0.00	0.000	1.000	1.120	1.865	1.645	2.06	0.170	0.418	0.354
S077	0.00	0.000	1.000	1.327	1.885	1.707	2.35	0.360	0.862	0.354
S076	0.00	0.000	0.964	1.597	2.249	2.194	2.50	0.153	0.675	0.707
S075	0.00	0.000	1.000	1.848	3.184	3.326	4.55	0.218	0.858	0.354
S074	0.00	0.000	0.929	1.309	1.640	1.664	1.86	0.186	0.713	0.707
S073	0.00	0.000	0.964	1.626	1.868	1.930	2.48	0.190	0.666	0.000
S072	0.00	1.000	1.000	1.283	14.469	2.321	2.31	0.175	0.559	0.707
S071	0.00	0.000	1.000	1.652	2.506	2.479	2.67	0.185	0.834	0.354
S070	0.00	0.250	0.788	1.907	2.070	2.267	2.46	0.169	0.643	0.000
S069	0.00	0.500	0.952	3.627	1.232	1.318	6.02	0.192	0.509	0.707
S068	0.00	0.500	0.621	1.335	1.479	2.720	3.73	0.163	0.320	0.354
S067	0.00	0.000	0.910	1.005	1.141	1.345	1.46	0.186	0.545	0.707
S066	0.00	1.000	1.000	2.697	3.905	6.625	5.19	0.437	0.868	1.061
S065	0.00	0.000	0.964	1.282	1.868	2.154	2.85	0.226	0.675	0.000
S064	0.00	0.000	1.000	2.103	3.373	2.784	4.02	0.079	0.823	0.354
S063	0.00	0.000	0.891	1.521	1.713	2.049	2.05	0.188	0.676	0.354
S062	0.00	0.000	1.000	1.922	2.015	2.030	2.41	0.084	0.534	0.354
S061	0.00	0.500	1.000	0.817	6.877	1.362	1.87	0.145	0.509	0.000
S060	0.00	0.000	0.964	1.567	2.094	2.395	3.00	0.210	0.509	0.354
S059	0.00	0.000	0.997	2.304	2.234	2.914	2.42	0.255	0.907	0.707
S058	0.00	0.000	1.000	2.149	3.804	2.734	4.26	0.209	0.647	1.414
S057	0.00	0.000	1.000	3.019	2.526	2.324	3.80	0.167	0.724	0.354
S056	0.00	0.000	1.000	1.477	1.661	2.534	2.42	0.181	0.577	1.061
S055	0.00	0.000	0.964	1.084	1.428	1.200	1.91	0.237	0.715	0.000
S054	0.00	0.000	0.857	2.392	3.006	2.951	3.40	0.158	0.597	0.707
S053	0.00	0.000	1.000	1.324	2.183	1.636	2.44	0.117	0.571	0.000
S052	0.00	0.000	1.000	1.873	2.227	2.108	2.54	0.140	0.537	0.354
S051	0.00	0.000	1.000	2.072	2.736	2.599	3.64	0.157	0.199	0.354
S050	0.00	0.000	1.000	1.454	2.037	2.662	2.68	0.216	0.460	0.000
S049	0.00	0.500	0.929	2.178	4.859	3.562	5.11	0.207	0.528	0.000
S048	0.00	0.000	1.000	1.377	1.914	2.253	2.99	0.196	0.537	0.354
S047	0.00	0.500	0.779	4.321	1.188	0.905	3.75	0.184	0.089	0.000
S046	0.00	0.000	1.000	1.099	1.136	1.422	1.60	0.100	0.666	0.707
S045	0.00	0.000	0.893	2.371	2.143	2.942	3.05	0.258	0.606	0.354
S044	0.00	0.000	0.964	1.625	2.098	2.295	3.22	0.170	0.699	0.354
S043	0.00	0.000	0.964	1.304	1.868	1.949	2.29	0.219	0.398	0.354
S042	0.00	0.000	1.000	1.204	1.659	1.917	2.41	0.160	0.545	1.061
S041	0.00	0.000	1.000	1.455	1.949	1.693	2.06	0.181	0.732	0.354
S040	0.00	0.000	1.000	1.422	1.965	1.220	1.95	0.121	0.687	0.707
S039	0.00	0.000	1.000	2.092	3.134	2.945	2.90	0.190	0.656	0.707
S038	0.00	0.500	0.964	3.351	6.988	3.231	6.15	0.196	0.687	0.354
S037	0.00	0.500	1.000	0.770	4.167	2.955	1.45	0.104	0.398	0.354
S036	0.00	0.000	0.996	1.325	1.921	1.766	2.58	0.226	0.728	0.354
S035	0.00	0.000	0.993	2.358	2.258	2.601	2.81	0.182	0.837	0.354
S034	0.00	0.000	1.000	2.966	3.338	4.372	5.71	0.182	0.617	0.354
S033	0.00	0.000	1.000	0.692	0.890	1.091	1.23	0.088	0.288	0.000
S032	0.00	0.000	1.000	1.131	1.565	2.121	2.21	0.148	0.736	0.000
S031	0.00	0.000	0.964	1.509	1.611	1.729	1.97	0.224	0.830	0.354
S030	0.00	0.500	0.776	3.296	2.679	4.596	4.46	0.222	0.948	0.000
S029	0.00	0.750	0.913	1.302	6.534	3.338	3.83	0.167	1.146	0.000
S028	0.00	0.000	0.964	1.741	3.268	2.695	3.60	0.172	0.585	0.707
S027	0.00	0.000	1.000	1.369	1.777	2.340	4.06	0.161	0.675	0.000
S026	0.00	0.500	1.000	4.696	5.658	5.382	6.23	0.173	0.790	0.354
S025	0.00	0.500	1.000	2.561	2.680	5.594	4.80	0.317	0.748	0.000
S024	0.00	0.000	1.000	2.115	3.116	3.465	3.90	0.182	0.835	1.414
S023	0.00	0.000	1.000	1.548	1.875	2.191	2.89	0.277	0.674	0.000
S022	0.00	0.000	1.000	1.121	1.435	1.802	2.78	0.217	0.610	0.000
S021	0.00	1.000	1.000	4.232	3.404	6.555	7.42	0.484	0.819	1.061
S020	0.00	0.250	0.860	1.631	2.575	2.375	3.25	0.256	1.017	1.414
S019	0.00	0.250	0.893	1.980	2.789	3.059	5.71	0.205	0.744	0.354
S018	0.00	0.000	1.000	1.658	2.039	2.027	2.61	0.146	0.656	1.061
S017	0.00	0.000	0.964	1.299	1.681	1.911	2.06	0.201	0.937	0.354
S016	0.00	0.500	0.964	4.064	5.145	3.684	5.76	0.076	0.551	0.354
S015	0.00	0.000	1.000	1.045	1.275	1.418	2.60	0.292	0.713	0.354
S014	0.00	0.000	1.000	0.818	1.350	1.324	1.52	0.225	0.467	0.354
S013	0.00	0.000	1.000	1.071	1.270	1.418	2.42	0.093	0.710	0.000
S012	0.00	0.500	0.821	3.183	5.186	5.265	5.37	0.193	0.577	0.354
S011	0.00	1.000	1.000	1.871	2.802	2.380	3.38	0.155	0.814	0.354	0.667	1.188	3.28	3.53	0.313	0.130	0.769
S010	0.00	0.000	0.964	1.848	2.864	2.614	3.65	0.263	1.243	0.000	0.667	1.624	4.46	5.13	0.307	0.138	0.737
S009	0.00	0.000	1.000	1.347	2.064	2.250	2.51	0.296	0.635	0.354
S008	2.00	0.500	0.762	3.125	0.986	1.307	1.29	0.024	0.000	0.000
S007	0.00	0.000	0.929	1.095	1.324	1.792	2.00	0.211	0.702	0.707
S006	0.00	0.000	1.000	1.950	2.418	2.383	3.76	0.290	0.960	0.354	0.667	0.930	3.35	3.41	0.324	0.131	0.556
S005	0.00	0.000	1.000	1.828	2.952	2.998	3.55	0.163	0.577	0.707
S004	0.00	0.750	0.893	5.980	2.109	2.576	3.29	0.187	0.713	0.354
S003	2.00	0.000	0.857	0.955	1.375	2.160	1.96	0.216	0.847	0.000	0.613	0.719	1.59	3.71	0.102	0.098	0.819
S002	0.00	0.000	0.917	1.690	2.410	2.997	2.71	0.254	0.571	0.354	0.667	0.798	2.27	1.96	0.159	0.146	0.624
S001	0.00	1.000	0.728	1.912	2.523	4.542	7.27	0.179	0.659	0.707

# Inspection: select(sub[sub$Participant == "S008", ], starts_with("Item_PID"))

sub[
  sub$Participant %in% outliers_questionnaires,
  names(sub)[!names(sub) %in% c(
    "Participant", "Nationality", "Age",
    "Ethnicity", "Sex", "Student", "Education",
    "Interval", "AttentionCheck_Session1",
    "AttentionCheck_Session2"
  )]
] <- NA

Final Sample

We collected data from 101 participants.

illusion1 <- illusion1[!illusion1$Participant %in% outliers_illusion1, ]
illusion2 <- illusion2[!illusion2$Participant %in% outliers_illusion1, ]
perceptual <- perceptual[!perceptual$Participant %in% outliers_illusion1, ]
sub <- sub[!sub$Participant %in% outliers_illusion1, ]

The final sample included 100 participants (Mean age = 29.0, SD = 8.3, range: [20, 54]; Sex: 49.0% females, 51.0% males, 0.0% other; Education: High school, 30.00%; Bachelor, 53.00%; Master, 16.00%; Doctorate, 1.00%; Other, 0.00%), from which 2 (2.00%) completed session 2.

Country of Origin

select(sub, region = Nationality) |>
  group_by(region) |>
  summarize(n = n()) |>
  right_join(map_data("world"), by = "region") |>
  ggplot(aes(long, lat, group = group)) +
  geom_polygon(aes(fill = n)) +
  scale_fill_gradientn(colors = c("#FFEB3B", "red")) +
  theme_void() +
  ggtitle("Number of participants by country of origin")

Age

estimate_density(sub$Age) |>
  normalize(select = y) |> 
  ggplot(aes(x = x, y = y)) +
  geom_area(fill = "#607D8B") +
  geom_vline(xintercept = mean(sub$Age), color = "red") +
  geom_label(data = data.frame(x = mean(sub$Age) * 1.1, y = 0.95), color = "red", label = paste0("Mean = ", format_value(mean(sub$Age)))) +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0)) +
  labs(title = "Age", y = "Distribution", color = NULL) +
  theme_modern(axis.title.space = 10) +
  theme(
    plot.title = element_text(size = rel(1), face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "italic", hjust = 0.5),
    axis.text.y = element_blank(),
    axis.text.x = element_text(size = rel(0.8)),
    axis.title.x = element_blank()
  )

Ethnicity

plot_waffle <- function(sub, what = "Nationality", title = what, rows = 8, size = 3) {
  ggwaffle::waffle_iron(sub, what, rows = rows) |>
    ggplot(aes(x, y)) +
    geom_point(aes(color = group), shape = "square", size = size) +
    coord_equal() +
    ggtitle(title) +
    labs(fill = "", color = "") +
    theme_void() +
    theme(
      plot.title = element_text(face = "bold", hjust = 0.5),
      legend.key.height = unit(1, "mm"),
      legend.key.width = unit(1, "mm")
    )
}

plot_waffle(sub, "Ethnicity", rows = 10, size = 5) +
  scale_color_manual(values = c("Hispanic" = "#FF5722", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Asian" = "#FFC107", "Other" = "#795548"))

Education

sub |>
  ggplot(aes(x = Education)) +
  geom_bar(aes(fill = Education)) +
  scale_y_continuous(expand = c(0, 0), breaks= scales::pretty_breaks()) +
  scale_fill_viridis_d(guide = "none") +
  labs(title = "Education", y = "Number of Participants") +
  theme_modern(axis.title.space = 15) +
  theme(
    plot.title = element_text(size = rel(1), face = "bold", hjust = 0.5),
    plot.subtitle = element_text(face = "italic", hjust = 0.5),
    axis.text.y = element_text(size = rel(0.8)),
    axis.text.x = element_text(size = rel(0.8)),
    axis.title.x = element_blank()
  )

Save Preprocessed

write.csv(illusion1, "../data/preprocessed_illusion1.csv", row.names = FALSE)
write.csv(illusion2, "../data/preprocessed_illusion2.csv", row.names = FALSE)
write.csv(perceptual, "../data/preprocessed_perceptual.csv", row.names = FALSE)
write.csv(sub, "../data/preprocessed_questionnaires.csv", row.names = FALSE)